home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue48 / Clinic / SQLTraceU.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1999-05-17  |  3.8 KB  |  134 lines
  1. unit SQLTraceU;
  2. {$ifdef Windows}
  3.   'This app requires the 32-bit BDE'
  4. {$endif}
  5.  
  6. interface
  7.  
  8. uses
  9.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  10.   BDE, Grids, DBGrids, DB, DBTables, StdCtrls, ExtCtrls, Buttons;
  11.  
  12. type
  13.   TTraceForm = class(TForm)
  14.     lstTrace: TListBox;
  15.     chkTableOpen: TCheckBox;
  16.     DataSource1: TDataSource;
  17.     Table1: TTable;
  18.     Database1: TDatabase;
  19.     DBGrid1: TDBGrid;
  20.     TraceCategories: TGroupBox;
  21.     CBPrepared: TCheckBox;
  22.     CBExecuted: TCheckBox;
  23.     CBInputParams: TCheckBox;
  24.     CBFetchedData: TCheckBox;
  25.     CBStatement: TCheckBox;
  26.     CBConnect: TCheckBox;
  27.     CBTransaction: TCheckBox;
  28.     CBBlob: TCheckBox;
  29.     CBMisc: TCheckBox;
  30.     CBVendorErr: TCheckBox;
  31.     CBVendor: TCheckBox;
  32.     memTrace: TMemo;
  33.     btnClear: TSpeedButton;
  34.     Label1: TLabel;
  35.     Label2: TLabel;
  36.     procedure FormCreate(Sender: TObject);
  37.     procedure FormDestroy(Sender: TObject);
  38.     procedure chkTableOpenClick(Sender: TObject);
  39.     procedure chkTraceCategoryClick(Sender: TObject);
  40.     procedure lstTraceClick(Sender: TObject);
  41.     procedure btnClearClick(Sender: TObject);
  42.   private
  43.     FTraceBuffer: PTraceDesc;
  44.     FSQLTraceCallBack: TBDECallBack;
  45.     function GetTraceFlags: TTraceFlags;
  46.     function SQLTraceFunction(CBInfo: Pointer): CBRType;
  47.   end;
  48.  
  49. var
  50.   TraceForm: TTraceForm;
  51.  
  52. implementation
  53.  
  54. {$R *.DFM}
  55.  
  56. // Note that if Delphi 2 is running the component library will have opened
  57. // up the Database Explorer DLL (DBX.DLL) which will have opened up
  58. // SMCLIENT.DLL which is the important functionality of the SQL monitor.
  59. // If that DLL is opened but the SQL Monitor EXE isn't, then the Session
  60. // object will install its own SQL trace callback that will not work.
  61. // When it fails, it sets the Session's TraceFlags property [].
  62.  
  63. //In short, don't expect this to work if executed when Delphi 2 is running
  64.  
  65. procedure TTraceForm.FormCreate(Sender: TObject);
  66. begin
  67.   //Give listbox a horizontal scroll bar
  68.   SendMessage(lstTrace.Handle, lb_SetHorizontalExtent, 2000, 0);
  69.   //Set session trace flags
  70.   Session.TraceFlags := GetTraceFlags;
  71.   //Initialise BDE before trying to install callback
  72.   Session.Open;
  73.   //Allocate callback descriptor
  74.   GetMem(FTraceBuffer, SizeOf(TRACEDesc) + DBIMAXTRACELEN);
  75.   //Install BDE callback
  76.   FSQLTraceCallBack := TBDECallBack.Create(nil, nil, cbTRACE,
  77.     FTraceBuffer, SizeOf(TRACEDesc) + DBIMAXTRACELEN,
  78.     SQLTraceFunction, True);
  79. end;
  80.  
  81. procedure TTraceForm.FormDestroy(Sender: TObject);
  82. begin
  83.   //Uninstall BDE callback
  84.   FSQLTraceCallBack.Free;
  85.   FSQLTraceCallBack := nil;
  86.   //Deallocate descriptor
  87.   FreeMem(FTraceBuffer);
  88.   FTraceBuffer := nil;
  89. end;
  90.  
  91. procedure TTraceForm.chkTableOpenClick(Sender: TObject);
  92. begin
  93.   Table1.Active := chkTableOpen.Checked
  94. end;
  95.  
  96. function TTraceForm.GetTraceFlags: TTraceFlags;
  97. var
  98.   I, TraceValue: Integer;
  99. begin
  100.   TraceValue := 0;
  101.   //Get Tag values of checked checkboxes
  102.   for I := 0 to TraceCategories.ControlCount - 1 do
  103.     if TraceCategories.Controls[I] is TCheckBox then
  104.       if TCheckBox(TraceCategories.Controls[I]).Checked then
  105.         Inc(TraceValue, TraceCategories.Controls[I].Tag);
  106.   //Turn number into set
  107.   Result := TTraceFlags(Word(TraceValue))
  108. end;
  109.  
  110. function TTraceForm.SQLTraceFunction(CBInfo: Pointer): CBRType;
  111. begin
  112.   //Set a result to avoid warning, even though it is ignored
  113.   Result := cbrUSEDEF;
  114.   lstTrace.Items.Add(StrPas(PTraceDesc(CBInfo).pszTrace));
  115. end;
  116.  
  117. procedure TTraceForm.chkTraceCategoryClick(Sender: TObject);
  118. begin
  119.   //Set session trace flags
  120.   Session.TraceFlags := GetTraceFlags;
  121. end;
  122.  
  123. procedure TTraceForm.lstTraceClick(Sender: TObject);
  124. begin
  125.   memTrace.Text := lstTrace.Items[lstTrace.ItemIndex]
  126. end;
  127.  
  128. procedure TTraceForm.btnClearClick(Sender: TObject);
  129. begin
  130.   lstTrace.Clear
  131. end;
  132.  
  133. end.
  134.